Attribute VB_Name = "mBase64"

' +--------------------------------------------------------------------------+
' |                                                                          |
' |  Modul:          Base64 Encoder/Decoder                                  |
' |  Version:        1.24 - 09.10.2009                                       |
' |  Lizenz:         Keine. Frei verwendbar!                                 |
' |  Sprache:        Visual Basic 6.0                                        |
' |  Entwickler:     Vincenz Dreger                                          |
' |  Unterstützung:  Imperial Games                                          |
' |  Homepage:       http://vd-software.inside1.net                          |
' |                  http://imperial-games.de                                |
' |                                                                          |
' |  Beschreibung:   Mit diesem Modul können Sie Strings oder Byte-Arrays    |
' |                  Base64 codieren und decodieren. Die Funktionen sind     |
' |                  einfach aufgebaut und relativ schnell. Auf einem        |
' |                  Pentium 4 mit 3,2 GHz wird ein 1 MB großer String       |
' |                  in 0,42 Sek. codiert und in 0,46 Sek. decodiert.        |
' |                                                                          |
' +--------------------------------------------------------------------------+
' |                                                                          |
' |  Funktionen:     EncBase64  = String in Base64 String codieren.          |
' |                  DecBase64  = Base64 String in String decodieren.        |
' |                  EncBase64b = ByteArray in Base64 ByteArray codieren.    |
' |                  DecBase64b = Base64 ByteArray in ByteArray decodieren.  |
' |                  SetTab64   = Eine eigene Base64-Tabelle setzen.         |
' |                  RandomTab  = Zufällige Base64-Tabelle erstellen.        |
' |                  CurrentTab = Abfrage der aktuell gesetzten Tabelle.     |
' |                                                                          |
' +--------------------------------------------------------------------------+
' |                                                                          |
' |  Hinweis:        Die Decodier-Funktion prüft die Eingangsdaten nicht     |
' |                  weiter. Es ist darauf zu achten, daß der Funktion       |
' |                  nur der reine Base64 Code übergeben wird. Hinter den    |
' |                  ggf. am Ende stehenden Füllzeichen "=" darf nichts      |
' |                  anderes mehr angehängt werden!                          |
' |                                                                          |
' |  Verweis:        RFC 3548 ... http://tools.ietf.org/html/rfc3548         |
' |                                                                          |
' |  Haftung:                                                                |
' |                                                                          |
' |    1. Die Verwendung geschieht auf eigene Gefahr!                        |
' |                                                                          |
' |    2. Der Author übernimmt keine Haftung bei eventuellen                 |
' |       Schäden, welche durch die Verwendung entstehen könnten!            |
' |                                                                          |
' +--------------------------------------------------------------------------+

Option Explicit

Public Const Base64Pad = 61  'Base64 Füllzeichen "="

'Standard Base64-Tabelle:
Public Const Base64Tab = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"

'Laut RFC 3548 Alternative Tabelle "URL and Filename Safe":
'Const Base64Tab = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789-_"

'Es kann auch eine beliebig andere Base64-Tabelle benutzt werden und mit
'SetTab64 übergeben werden. Vorraussetzung: 64 Zeichen lang, keine
'doppelten Zeichen und das Füllzeichen darf nicht vorkommen!

Private BPad As Byte
Private BTab() As Byte
Private TabInit As Boolean
Private tTab(256) As Byte
Private CTab As String
Private CPad As String

Public Const ExistBase64 As Boolean = True


'Test-Funktion. Kann direkt ohne Projekt ausgeführt werden.
'Wenn dieses Modul in ein Projekt eingebunden wird, bitte
'die diese Funktion auskommentieren oder löschen!
Sub Main()

  Dim S As String
  Dim E As String
  Dim D As Variant

  S = "Hallo! Dies ist ein kleiner Test mit dem Base64-Encoder."

  Debug.Print
  Debug.Print S

  E = EncBase64(S)
  Debug.Print E

  D = DecBase64(E)
  Debug.Print D

End Sub


'Eine Base64-Tabelle ins ByteArray kopieren. Wird keine eigene Tabelle
'übergeben, so wird die als Konstante definierte Standard-Tabelle verwendet.
'Optional kann auch ein alternatives Füllzeichen (Pad) übergeben werden.
'Die aktuell verwendete Tabelle kann mit CurrentTab abgefragt werden.
Public Sub SetTab64(Optional ByVal Table64 As String = Base64Tab, Optional ByVal Pad As String)
  
  Dim BytPos As Long
  
  'Nur ausführen, wenn vorgegebene Tabelle = 64 Zeichen hat
  If Len(Table64) = 64 Then
    
    'Wandle Unicode Base64-Tabelle in Ascii ByteArray
    BTab() = StrConv(Table64, vbFromUnicode)
    
    'ByteArray-Tabelle zurücksetzen
    Erase tTab()
    
    'Rückwärts-Tabelle erstellen.
    For BytPos = 0 To 63
      tTab(BTab(BytPos)) = BytPos
    Next
    
    'Wenn Table64 = Standard Base64Tab, dann:
    'Ergänzung der Rückwärtstabelle um gleichzeitig mit der Standard und
    'der alternativen Base64-Tabelle codierte Strings decodieren zu können.
    If Table64 = Base64Tab Then
      tTab(43) = 62   ' "+" = (Standard Base64-Tabelle)
      tTab(47) = 63   ' "/" = ...
      tTab(45) = 62   ' "-" = (alternative Base64-Tabelle)
      tTab(95) = 63   ' "_" = ...
      tTab(126) = 63  ' "~" = ...
    End If
    
    'Aktuelle Tabelle als String speichern.
    CTab = Table64
      
  Else
    
    'Wenn Table64 nicht 64 Zeichen lang, dann Standard-Tabelle verwenden
    BTab() = StrConv(Base64Tab, vbFromUnicode)
    CTab = Base64Tab
  
  End If
  
  'Füllzeichen setzen
  If Pad = "" Then
    BPad = Base64Pad
  Else
    BPad = Asc(Left(Pad, 1))
  End If
  CPad = Chr(BPad)
  
  'TabInit auf Wahr setzen, damit SetTab64 nur 1 mal automatisch aufgerufen wird.
  TabInit = True

End Sub


'Aktuell gesetzte Tabelle ausgeben.
Public Function CurrentTab() As String
  If TabInit = False Then Call SetTab64
  CurrentTab = CTab
End Function

'Aktuell gesetztes Füllzeichen ausgeben.
Public Function CurrentPad() As String
  If TabInit = False Then Call SetTab64
  CurrentPad = CPad
End Function


'Erstellt anhand einer vorgegebenen Tabelle eine Zufalls-Tabelle.
'Wird keine Tabelle vorgegeben, so wird die Standard-Tabelle verwendet.
'Die Zufalls-Tabelle muss mit "SetTab64 RandomTab" übergeben werden.
Public Function RandomTab(Optional ByVal Table64 As String = Base64Tab) As String

  Dim StrPos As Long
  Dim StrMid As String
  Dim NewTab As String
  
  'Nur ausführen, wenn vorgegebene Tabelle = 64 Zeichen hat.
  If Len(Table64) = 64 Then
    
    'Startwert für Zufallsgenerator setzen.
    Randomize CDbl(Date + Time + Timer)
    
    'Schleife ausführen, solange neue Tabelle < 64 Zeichen ist.
    Do
      StrPos = Int(Rnd * 64) + 1         'Zufalls-Position (1-64).
      StrMid = Mid$(Table64, StrPos, 1)  'Zeichen aus Vorgabe-Tabelle holen.
      If InStr(NewTab, StrMid) = 0 Then  'Wenn Zeichen noch nicht vorhanden,
        NewTab = NewTab + StrMid         'dann in Zufalls-Tabelle hinzufügen.
      End If
    Loop While Len(NewTab) < 64
    
    RandomTab = NewTab
    
  End If

End Function


'Beliebigen String in ein Base64 codieren String wandeln
Public Function EncBase64(ByVal InString As String, Optional ByVal BlockLen As Integer = 0, Optional ByVal Spaces As Integer = 0) As String

  'BlockLen = Optionale Zeilenlänge um einen Base64 Block zu generieren.
  'Spaces   = Optional Leerzeichen vor Zeile einfügen.
  
  If Len(InString) = 0 Then Exit Function

  Dim IByt() As Byte
  Dim OByt() As Byte
  Dim OutStr As String

  IByt() = StrConv(InString, vbFromUnicode)  'Wandle Unicode-String in Ascii ByteArray
  OByt() = EncBase64b(IByt())                'Base64 codieren
  OutStr = StrConv(OByt(), vbUnicode)        'Wandle Ascii ByteArray in Unicode-String
  
  'Optional aus dem Base64-String ein Block mit fester Zeilenlänge machen.
  If BlockLen > 0 Then OutStr = MakeBlock(OutStr, BlockLen, Spaces)
  
  EncBase64 = OutStr

End Function


'Base64 codieren String in ein String decodieren.
Public Function DecBase64(ByVal InString As String) As String

  Dim IByt() As Byte
  Dim OByt() As Byte
  Dim OutStr As String

  'ACHTUNG: Replace$ gibts erst ab VB6.  Für VB5 wird dazu ein Modul benötigt!
  
  'HINWEIS: Die Replace Funktion ist langsam. Wenn nicht gebraucht, kann sie
  '         auch auskommentiert werden.
  
  InString = Replace$(InString, " ", "")       'Leerzeichen entfernen
  InString = Replace$(InString, Chr$(10), "")  'Zeilenumbrüche entfernen
  InString = Replace$(InString, Chr$(13), "")
  
  If Len(InString) < 4 Then Exit Function

  IByt() = StrConv(InString, vbFromUnicode)
  OByt() = DecBase64b(IByt())                'Base64 decodieren
  OutStr = StrConv(OByt(), vbUnicode)
  
  DecBase64 = OutStr

End Function


'Ascii ByteArray in Base64 ByteArray codieren
Public Function EncBase64b(InBytes() As Byte) As Variant

  Dim EndTrm As Byte
  Dim IByLen As Long
  Dim LngBuf As Long
  Dim BytPos As Long
  Dim OutCnt As Long
  Dim OutLen As Long
  Dim OBytes() As Byte
  
  IByLen = UBound(InBytes()) + 1    'Größe des ByteArray ermitteln.
  If IByLen = 0 Then Exit Function  'Wenn InBytes leer, dann Funktion verlassen.
  
  'InBytes Array auf eine durch 3 teilbare Länge bringen.
  'Dadurch entstehen 0, 1 oder 2 Füllzeichen (Null-Bytes).
  EndTrm = 3 - (IByLen Mod 3)
  If EndTrm > 2 Then EndTrm = 0
  ReDim Preserve InBytes(IByLen + EndTrm)
  
  IByLen = UBound(InBytes()) + 1
  OutLen = IByLen * 4 / 3           'Größe des OBytes Arrays berechnen
  ReDim OBytes(OutLen - 2) As Byte  'OBytes Array dimensionieren
    
  'Base64-Tabelle initialisieren, wenn nicht bereits passiert
  If TabInit = False Then Call SetTab64

  'InString ByteArray in 3er-Schritten durchlaufen
  For BytPos = 0 To IByLen - 3 Step 3
    LngBuf = 0                                           'Long-Buffer auf 0 rücksetzen
    LngBuf = LngBuf * 256 + InBytes(BytPos + 0)          '8Bit Byte 1 in Long-Buffer holen
    LngBuf = LngBuf * 256 + InBytes(BytPos + 1)          '     Byte 2 "
    LngBuf = LngBuf * 256 + InBytes(BytPos + 2)          '     Byte 3 "
    OBytes(OutCnt + 0) = BTab((LngBuf \ 262144) And 63)  '6Bit Byte 1 ins OBytes Array schreiben
    OBytes(OutCnt + 1) = BTab((LngBuf \ 4096) And 63)    '     Byte 2 "
    OBytes(OutCnt + 2) = BTab((LngBuf \ 64) And 63)      '     Byte 3 "
    OBytes(OutCnt + 3) = BTab(LngBuf And 63)             '     Byte 4 "
    OutCnt = OutCnt + 4
  Next
  
  'Füllzeichen mit "=" ersetzen, um sie beim Decodieren erkennen zu können.
  For BytPos = 1 To EndTrm
    OBytes(OutLen - 1 - BytPos) = BPad
  Next
  
  EncBase64b = OBytes()

End Function


'Base64 ByteArray in Ascii ByteArray decodieren
Public Function DecBase64b(InBytes() As Byte) As Variant
  
  Dim EndTrm As Byte
  Dim IByLen As Long
  Dim LngBuf As Long
  Dim StrLen As Long
  Dim BytPos As Long
  Dim OutCnt As Long
  Dim OutLen As Long
  Dim OutStr As String
  Dim OBytes() As Byte
  Dim CrcStr As String
  
  IByLen = UBound(InBytes()) + 1
  If IByLen < 4 Then Exit Function
  
  'Radix64 CRC24 verarbeiten/filtern ...
  If IByLen > 5 Then
    If InBytes(IByLen - 5) = BPad Then
      'For BytPos = 0 To 3
      '  CrcStr = CrcStr + Chr$(InBytes(IByLen - (4 - BytPos)))
      'Next
      'CrcStr = DecBase64(CrcStr)
      ReDim Preserve InBytes(IByLen - 5)
      IByLen = UBound(InBytes()) + 1
    End If
  End If
  
  'Füllzeichen "=" ermitteln.
  If InBytes(IByLen - 1) = BPad Then EndTrm = 1
  If InBytes(IByLen - 2) = BPad Then EndTrm = 2

  'InBytes Array auf eine durch 4 teilbare Länge bringen.
  IByLen = UBound(InBytes()) + 1
  OutLen = (IByLen * 3 / 4) - 1
  ReDim OBytes(OutLen) As Byte

  If TabInit = False Then Call SetTab64
  
  'InString ByteArray in 4er-Schritten durchlaufen.
  For BytPos = 0 To IByLen - 4 Step 4
    LngBuf = 0
    LngBuf = LngBuf * 64 + tTab(InBytes(BytPos + 0))  '6Bit Byte 1 in Long-Buffer holen
    LngBuf = LngBuf * 64 + tTab(InBytes(BytPos + 1))  '     Byte 2 "
    LngBuf = LngBuf * 64 + tTab(InBytes(BytPos + 2))  '     Byte 3 "
    LngBuf = LngBuf * 64 + tTab(InBytes(BytPos + 3))  '     Byte 4 "
    OBytes(OutCnt + 0) = (LngBuf \ 65536) And 255     '8Bit Byte 1 ins OBytes Array schreiben
    OBytes(OutCnt + 1) = (LngBuf \ 256) And 255       '     Byte 2 "
    OBytes(OutCnt + 2) = LngBuf And 255               '     Byte 3 "
    OutCnt = OutCnt + 3
  Next
  
  'Füllzeichen am Ende des OBytes Arrays abtrennen.
  ReDim Preserve OBytes(OutLen - EndTrm) As Byte
  
  DecBase64b = OBytes()

End Function


'Hilfsfunktion um ein Block mit fester Zeilenlänge
'aus dem Base64 codierten Strings zu erzeugen.
Public Function MakeBlock(ByVal InString As String, ByVal BlockLen As Integer, ByVal Spaces As Integer)
  Dim MidPos As Long
  Dim MidStr As String
  For MidPos = 1 To Len(InString) Step BlockLen
    MidStr = MidStr + Space$(Spaces) + Mid(InString, MidPos, BlockLen) + vbCrLf
  Next
  MakeBlock = MidStr
End Function